Chip 2000 November

home *** CD-ROM | disk | FTP | other *** search

/ Chip 2000 November / Chip Kasım 2000.iso / prog / share / 11 / setup.exe / %MAINDIR% / DEMOS / CIFTP / FTPCLASS / CLSFTP.CLS next >

Wrap

Text File | 2000-09-07 | 58.7 KB | 1,517 lines

VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "clsFTP" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ' SUBJECT: clsFTP ' AUTHOR: David M Swan ' Progress Software Corporation ' Crescent Division ' ' CREATED: December 8, 1996 ' ' REVISION ' HISTORY: ' ' DESCRIPTION: Encapsulates many of the CIFTP control's functions in a class module ' See FtpClass.wri for detailed description of the class. ' ' PUBLIC ' INTERFACE: FUNCTIONS - bLogin, bLogout, bGetDirectory, bGetFile, bPutFile, bAbort, ' sGetLastError, lTotalDataBytesIn, lTotalDataBytesOut ' ' PUBLIC PROPERTIES - iTimeoutValue, bDumpAccessPackets, bDumpDataPackets ' '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' ======================== ' Define the public class members: ' ======================== Public iTimeoutValue As Integer ' max # of seconds to wait for a server response before bailing out. Set to 0 for infinite wait ' Debug control flags... Public bDumpAccessPackets As Boolean ' Controls whether Access Control Packets are dumped to debug window Public bDumpDataPackets As Boolean ' Controls whether Data Channel Packets are dumped to debug window ' ======================== ' Define the private class members: ' ======================== Private objFTP As CIFTP ' The FTP control being encapsulated - This is set in bInit Private bInitialized As Boolean ' Set to True once bInit has been called successfully Private bUserLoggingOut As Boolean ' Flag indicating whether the user is logging out (set to True in user func bLogout) ' This is used to determine if the Access Channel is closing due to a logout request (via bLogout) ' or was initiated by the server. Private bAccessControlChannelOpen As Boolean ' Set to True when EventState = CIFTP_ACCONN ' Set to False when EventState = CIFTP_ACCLOSED Private bDataControlChannelOpen As Boolean ' Set to True when EventState = CIFTP_DCCONN ' Set to False when EventState = CIFTP_DCCLOSED Private dtLastUserRequest As Date ' Time at which the user last called a public function Private dtLastServerResponse As Date ' Used to track the time the last server data was received ' (Set in: DataControlPacketRecieved/Sent, EventStateChanged and ServerResponse Events) Private sCurrUserFuncName As String ' Name of the currently executing client function Private bFileClosed As Boolean ' Set to True in EventStateChanged, to False in bExecCmd. Used for LIST and RETR cmd processing Private m_lTotalDataBytesIn As Long ' counter for total bytes that come in during a data transfer (to the client -- RETR) Private m_lTotalDataBytesOut As Long ' counter for total bytes that are sent out during a data transfer (to the server -- STOR) ' Note use the corresponding public Property Get functions to access these from client code ' Consts identifying each of the public functions (used by DumpFTPSettings) Private Const USER_FUNC_NONE As Byte = 0 Private Const USER_FUNC_LOGIN As Byte = 1 Private Const USER_FUNC_LOGOUT As Byte = 2 Private Const USER_FUNC_GET_DIR As Byte = 3 Private Const USER_FUNC_GET_FILE As Byte = 4 Private Const USER_FUNC_PUT_FILE As Byte = 5 Private Const DEFAULT_TIMEOUT As Integer = 60 ' Default timeout in seconds Private Const ERROR_TYPE_NONE As Byte = 0 ' No Error Private Const ERROR_TYPE_WSA As Byte = 1 ' WSAError event fired Private Const ERROR_TYPE_INTERNET As Byte = 2 ' InternetError event fired Private Const ERROR_TYPE_OTHER As Byte = 3 ' Catch all for all other types of errors ' These are either usually caused by bad parameters ' or an attempt by the user to call a function without ' having the system in the proper state (e.g. calling a ' function w/o first logging in) ' Values when LastError.iType = ERROR_TYPE_OTHER ' ======================================== Private Const ERR_ROUTINE_ERROR As Byte = 1 Private Const ERR_BAD_OR_MISSING_PARAM As Byte = 2 Private Const ERR_USER_ERROR As Byte = 3 ' e.g. user called Init but the class is already initialized Private Const ERR_CLASS_NOT_INITIALIZED As Byte = 4 ' user is calling a function w/o first initializing the class Private Const ERR_UNEXPECTED_STATE As Byte = 5 ' e.g. user calls bLogout, but there access channel is closed Private Const ERR_SERVER_REQUEST_FAILED As Byte = 6 ' catch all for errors calling bExecCmd Private Const ERR_ACCESS_CONN_LOST As Byte = 7 ' set in the case that the access channel drops unexpectedly Private Const ERR_TIMED_OUT As Byte = 8 ' timeout period expired waiting on an operation to complete Private Const ERR_INVALID_FUNC_CALL As Byte = 9 ' user attempted to call a function before another function had completed Private Const ERR_CMD_ABORTED As Byte = 10 ' the user called bAbort while a user function was executing Private Const ERR_INVALID_ABORT As Byte = 11 ' the user called bAbort, but no function was executing at the time Private Const ERR_NOT_CONNECTED As Byte = 12 ' attempted to call a function but there is no server connection Private Type udtERROR iType As Integer ' NONE, OTHER, WSA, or INTERNET lCode As Long End Type Private LastError As udtERROR ' Used to track error settings. Use SetError to load the structure Private iInternaleError As Integer ' Used to save Err.Number when an internal error occurs ' As server responses come in (via the CIFTP.ServerResponse event firing), we queue the information so ' that we can determine the result of server requests. The sequence is as follows: (1) We establish a ' data channel if necessary, (2) We issue a server request via bExecCmd, (3) As response(s) come in from ' the server, we queue them via AddToSRQueue, (4) We wait for the server's response via bWaitOnServerResponse. ' This routine looks in the response queue to determine the result of the request. All of these functions are ' private (and therefore hidden from the user). Private Type SR_NODE iCode As Integer sMsg As String End Type Private Const QUEUE_SIZE As Byte = 10 Private SRQueue(1 To QUEUE_SIZE) As SR_NODE Private iQPos As Integer ' current Queue position ' Consts representing the commands supported by bExecCmd function... '==================================================== Private Const CMD_USER As Byte = 1 Private Const CMD_PASS As Byte = 2 Private Const CMD_CWD As Byte = 3 Private Const CMD_CDUP As Byte = 4 Private Const CMD_QUIT As Byte = 5 Private Const CMD_PASV As Byte = 6 Private Const CMD_TYPE As Byte = 7 Private Const CMD_STOR As Byte = 8 Private Const CMD_RETR As Byte = 9 Private Const CMD_LIST As Byte = 10 Private Const CMD_APPE As Byte = 11 Private Const CMD_PWD As Byte = 12 Private Const CMD_SYST As Byte = 13 Private Const NUM_SUPPORTED_CMDS As Byte = 13 ' MAKE SURE TO INCREASE THIS IF YOU ADD ADDITIONAL COMMANDS!!! Private Const SUCCESS As Byte = 1 Private Const FAILURE As Byte = 2 Private Const MAX_CODES As Byte = 15 ' Max # of codes indicating success or failure of a given server request ' This array represents the FTP state machine. The first dimension represents the ftp command being executed. ' The second dimension represents success or failure and the third dimension is the set of possible result codes ' for that particular command's successfull/failing values. The machine is initialized at startup by InitFTPStateMachine Private iFTPStateMachine(1 To NUM_SUPPORTED_CMDS, 1 To 2, 1 To MAX_CODES) As Integer ' Ideas for future enhancements... ' ============================ ' 1) Add an error collection ' 2) Add an actions (audit trail) collection to track each requested action and it's result. ' 2a) Audit trail log file ' 3) Optionally dump "DP" output to a window for run-time debugging/tracking ' 4) Add auto reconnect if the ftp server drops a connection after a period of inactivity. ' 5) Wrap the control's high level methods ' 6) Implement a function that wraps the SendFTPCommand function '==================================================== ' +++ Public Routine Implementation Starts Here +++ '==================================================== Public Function bInit(FTP As CIFTP) As Boolean ' Usage: Users MUST call this function first passing the CIFTP control they wish to wrap as the sole argument On Error GoTo bInit_ErrHdlr ClearErrorFlags dtLastUserRequest = Now If bInitialized Then bInit = False SetError ERR_USER_ERROR DP "ERROR - bInit already called!" Else Set objFTP = FTP InitFTPStateMachine bInitialized = True bInit = True End If Exit Function bInit_ErrHdlr: HandleInternalError End Function ' bInit Public Function bLogin(Optional vntHostName, Optional vntLoginName, Optional vntPassword, Optional vntWorkingDirectory) As Boolean ' Usage: After calling bInit, you can call this function to establish a connection with an ftp server. Be sure to either set the ' HostName, LoginName and Password properties in the CIFTP control or pass these as arguments to the function. ' This wraps the ConnectToAccessControlChannel, USER, PASS, CWD and PWD methods. ' Note that you can pass either the host name or an ip address in the vntHostName argument. Dim bSuccess As Boolean Const SR_USER_OK_NEED_PASS As Integer = 331 On Error GoTo bLogin_ErrHdlr bLogin = False ' Assume worst case If Not bInitUserCall("bLogin") Then Exit Function 'GoTo bLogin_GetOut ' Handle optional params... If Not IsMissing(vntHostName) Then ' Determine if it's an IP address... If bIsIPAddress(CStr(vntHostName)) Then objFTP.HostAddress = CStr(vntHostName) Else objFTP.HostName = CStr(vntHostName) End If End If If Not IsMissing(vntLoginName) Then objFTP.LoginName = CStr(vntLoginName) If Not IsMissing(vntPassword) Then objFTP.Password = CStr(vntPassword) If Not IsMissing(vntWorkingDirectory) Then objFTP.WorkingDirectory = CStr(vntWorkingDirectory) DumpFTPSettings (USER_FUNC_LOGIN) ' Dump relevant FTP login settings ' Make sure that either a host name or address has been set... If objFTP.HostName = "" And objFTP.HostAddress = "" Then SetError ERR_BAD_OR_MISSING_PARAM DP "ERROR: HostName or HostAddress must be set" GoTo bLogin_GetOut End If ' Establish an access control channel with the ftp server... If Not bConnectToAccessControlChannel() Then GoTo bLogin_GetOut ' Login and set the working directory... If Not bExecCmd(CMD_USER) Then GoTo bLogin_GetOut ' Only send the password if the server requires it... If bCheckSRQueue(SR_USER_OK_NEED_PASS) Then DP "Server needs PASS, sending..." If Not bExecCmd(CMD_PASS) Then GoTo bLogin_GetOut End If ' (Possibly) change to the dir specified in the WorkingDirectory property If objFTP.WorkingDirectory <> "" Then If Not bExecCmd(CMD_CWD) Then GoTo bLogin_GetOut End If ' Update the WorkingDirectory property... If Not bExecCmd(CMD_PWD) Then GoTo bLogin_GetOut bLogin = True ' if we got here, then we've successfully connected bLogin_GetOut: EndUserCall Exit Function bLogin_ErrHdlr: HandleInternalError EndUserCall End Function ' bLogin Public Function bGetFile(Optional vntLocalFileName, Optional vntRemoteFileName, Optional vntBinaryFile) As Boolean ' Usage: Get a file using the low level ftp methods. Be sure to set the CIFTP control's LocalFileName, RemoteFilename properties ' before calling this function or pass these as arguments to the funciton. This wraps the PASV, ConnectToDataChannel ' and RETR methods. If vntBinaryFile is True then the RepresentationType is set to binary (I) otherwise it is set ' to ASCII. If it is not supplied, binary is assumed Dim bSuccess As Boolean, bBinaryFile As Boolean On Error GoTo bGetFile_ErrHdlr bGetFile = False ' Assume worst case. If Not bInitUserCall("bGetFile") Then Exit Function 'GoTo bGetFile_GetOut ' Handle optional parameters... If Not IsMissing(vntLocalFileName) Then objFTP.LocalFileName = CStr(vntLocalFileName) If Not IsMissing(vntRemoteFileName) Then objFTP.RemoteFileName = CStr(vntRemoteFileName) If Not IsMissing(vntBinaryFile) Then bBinaryFile = CBool(vntBinaryFile) Else bBinaryFile = True ' Treat as a binary file if not specified. End If DumpFTPSettings (USER_FUNC_GET_FILE) ' Dump relevant FTP settings for getting a file ' Make sure we're logged in! If Not bLoggedIn() Then HandleNotLoggedIn GoTo bGetFile_GetOut End If ' Check to make sure local/remote file names have been set... If objFTP.LocalFileName = "" Or objFTP.RemoteFileName = "" Then DP "ERROR: Local and/or Remote File Name Not Specified" SetError ERR_BAD_OR_MISSING_PARAM GoTo bGetFile_GetOut End If ' Set the RepresentationType and call the TYPE method... If bBinaryFile Then objFTP.RepresentationType = "I" Else objFTP.RepresentationType = "A" End If If Not bExecCmd(CMD_TYPE) Then GoTo bGetFile_GetOut ' Establish a data channel with the ftp server...This will call PASV and ConnectToDataChannel If Not bConnectToDataChannel() Then GoTo bGetFile_GetOut ' We now have a data channel, so we can call RETR... If Not bExecCmd(CMD_RETR) Then GoTo bGetFile_GetOut ' If we've gotten here, then the command was successful bGetFile = True DP "Total bytes received: " & lTotalDataBytesIn bGetFile_GetOut: EndUserCall Exit Function bGetFile_ErrHdlr: HandleInternalError EndUserCall End Function ' bGetFile Public Function bPutFile(Optional vntLocalFileName, Optional vntRemoteFileName, Optional vntBinaryFile, Optional vntAppend) As Boolean ' Usage: Put a file using the low level ftp methods. Be sure to set the CIFTP control's LocalFileName, RemoteFilename properties ' before calling this function or pass these as arguments to the funciton. If you wish to append to a file on the server you ' must pass the optional append argument to the routine (as True). This wraps the PASV, ConnectToDataChannel ' and STOR/APPE methods. If vntBinaryFile is True then the RepresentationType is set to binary (I) otherwise it is set ' to ASCII. If it is not supplied, binary is assumed Dim bSuccess As Boolean, bAppendToFile, bBinaryFile As Boolean On Error GoTo bPutFile_ErrHdlr bPutFile = False ' Assume worst case. If Not bInitUserCall("bPutFile") Then Exit Function 'GoTo bPutFile_GetOut ' Handle optional parameters... If Not IsMissing(vntLocalFileName) Then objFTP.LocalFileName = CStr(vntLocalFileName) If Not IsMissing(vntRemoteFileName) Then objFTP.RemoteFileName = CStr(vntRemoteFileName) If Not IsMissing(vntAppend) Then bAppendToFile = CBool(vntAppend) If Not IsMissing(vntBinaryFile) Then bBinaryFile = CBool(vntBinaryFile) Else bBinaryFile = True ' Treat as a binary file if not specified. End If DumpFTPSettings (USER_FUNC_PUT_FILE) ' Dump relevant FTP settings for putting a file ' Make sure we're logged in! If Not bLoggedIn() Then HandleNotLoggedIn GoTo bPutFile_GetOut End If ' Check to make sure local/remote file names have been set... If objFTP.LocalFileName = "" Or objFTP.RemoteFileName = "" Then DP "ERROR: Local and/or Remote File Name Not Specified" SetError ERR_BAD_OR_MISSING_PARAM GoTo bPutFile_GetOut End If ' Set the RepresentationType and call the TYPE method... If bBinaryFile Then objFTP.RepresentationType = "I" Else objFTP.RepresentationType = "A" End If If Not bExecCmd(CMD_TYPE) Then GoTo bPutFile_GetOut ' Establish a data channel with the ftp server...This will call PASV and ConnectToDataChannel If Not bConnectToDataChannel() Then GoTo bPutFile_GetOut ' We now have a data channel, so we can call STOR/APPE... If bAppendToFile Then bSuccess = bExecCmd(CMD_APPE) Else bSuccess = bExecCmd(CMD_STOR) End If If Not bSuccess Then GoTo bPutFile_GetOut ' If we've gotten here, then the command was successful bPutFile = True DP "Total bytes sent: " & lTotalDataBytesOut bPutFile_GetOut: EndUserCall Exit Function bPutFile_ErrHdlr: HandleInternalError EndUserCall End Function ' bPutFile Public Function bGetDirectory(Optional vntWorkingDirectory) As Boolean ' Usage: Use this function to populate the files collection and dir/files list boxes. Be sure to set ' the WorkingDirectory property to the desired location before invoking this function or pass this as ' an argument to the function. This wraps the ConnectToDataChannel, CWD, LIST and PWD methods. Dim bSuccess As Boolean On Error GoTo bGetDirectory_ErrHdlr bGetDirectory = False ' Assume worst case If Not bInitUserCall("bGetDirectory") Then Exit Function 'GoTo bGetDirectory_GetOut ' Make sure we're logged in! If Not bLoggedIn() Then HandleNotLoggedIn GoTo bGetDirectory_GetOut End If ' Handle optional argument... If Not IsMissing(vntWorkingDirectory) Then objFTP.WorkingDirectory = CStr(vntWorkingDirectory) ' NOTE: If the LocalFileName property is set when you call the list method, the resulting output ' is dumped to the specified file. Therefore, be sure to reset this to a known value after doing ' a get or a put or else you may accidentally overwrite a file you didn't intend to. ' We set it to a file in the application directory here so that the FileClosed event will fire at the end ' of the LIST function. objFTP.LocalFileName = App.Path & "\$$FtpDir.tmp" DumpFTPSettings (USER_FUNC_GET_DIR) ' Dump relevant FTP Get dir settings ' Set type to ASCII... objFTP.RepresentationType = "A" bSuccess = bExecCmd(CMD_TYPE) If Not bSuccess Then GoTo bGetDirectory_GetOut ' Get a data channell... bSuccess = bConnectToDataChannel() ' this will call PASV and ConnectToDataChannel If Not bSuccess Then GoTo bGetDirectory_GetOut ' (Possibly) change dirs to that specified in the WorkingDirectory property bSuccess = bExecCmd(CMD_CWD) If Not bSuccess Then GoTo bGetDirectory_GetOut ' Now execute the list command to update the files collection and list boxes bSuccess = bExecCmd(CMD_LIST) If Not bSuccess Then GoTo bGetDirectory_GetOut ' Update the WorkingDirectory property bSuccess = bExecCmd(CMD_PWD) bGetDirectory_GetOut: bGetDirectory = bSuccess EndUserCall Exit Function bGetDirectory_ErrHdlr: HandleInternalError EndUserCall End Function ' bGetDirectory Public Function bLogout() As Boolean ' Usage: Terminate the connection (established by bLogin) to the ftp server On Error GoTo bLogout_ErrHdlr bLogout = False ' Assume worst case If Not bInitUserCall("bLogout") Then Exit Function 'GoTo bLogout_GetOut ' Make sure we're logged in! If Not bLoggedIn() Then HandleNotLoggedIn GoTo bLogout_GetOut End If ' Set flag indicating user is initiating shutdown. This is looked at in EventStateChanged when ' the access channel closes. If it is unexpected, corrective action can be taken. bUserLoggingOut = True bLogout = bExecCmd(CMD_QUIT) bLogout_GetOut: EndUserCall Exit Function bLogout_ErrHdlr: HandleInternalError EndUserCall End Function ' bLogout Public Function bAbort() As Boolean 'Usage: Abort the currently executing user command. If sCurrUserFuncName <> "" Then ' abort the currently executing user request SetError ERR_CMD_ABORTED bAbort = True ' If the data channel is active, then terminate it via the CleanupDataConnection method ' This allows users to abort file transfers If bDataControlChannelOpen Then DP "Operation terminated via bAbort, closing data channel..." CloseDataControlChannel End If Else ' no user request is currently under way, so there is nothing to abort SetError ERR_INVALID_ABORT bAbort = False End If End Function ' bAbort Public Function sGetLastError() As String ' Usage: If an error occurs, use this function to get a human readable description of the problem Dim sErr As String On Error Resume Next Select Case LastError.iType Case ERROR_TYPE_NONE ' No Error sErr = "No Error" Case ERROR_TYPE_WSA ' WSAError event fired sErr = "WSAError - " & WSAErrDescription(CInt(LastError.lCode)) Case ERROR_TYPE_INTERNET ' InternetError event fired sErr = "InternetError - " & InternetErrDescription(LastError.lCode) Case ERROR_TYPE_OTHER ' There was an internal error in the routine (possibly caused by bad/missing user param) sErr = sGetOtherError() Case Else sErr = "Unknown Error Type!" End Select sGetLastError = sErr End Function ' sGetLastError Public Sub ServerResponse(ByVal iCode As Integer, sMsg As String) ' Usage: This MUST be called from the ServerResponse event code for the CIFTP control that is being wrapped AddToSRQueue iCode, sMsg dtLastServerResponse = Now ' record the time that server last sent info End Sub ' ServerResponse Public Sub EventStateChanged(iState As Integer) ' Usage: This MUST be called from the EventStateChanged event code for the CIFTP control that is being wrapped On Error GoTo EventStateChanged_ErrHdlr Select Case iState Case CIFTP_FCLOSED ' File Closed DP "File Closed" bFileClosed = True ' used to end LIST and RETR calls Case CIFTP_SCLOSED ' Socket Closed DP "Socket Closed" Case CIFTP_ACCONN ' Access Control Channel Connection DP "AccessControlChannelConnection" bAccessControlChannelOpen = True Case CIFTP_ACCLOSED ' Access Channel Closed DP "AccessControlChannelClosed" If Not bUserLoggingOut Then ' To-do: Logic to handle case where access control channel is unexpectedly dropped... DP "Timeout may have occured. Access channel lost at " & Now DP "Last user request occured at " & dtLastUserRequest SetError (ERR_ACCESS_CONN_LOST) End If bAccessControlChannelOpen = False Case CIFTP_DCCONN ' Data Channel Connection DP "Data control connection established" bDataControlChannelOpen = True m_lTotalDataBytesIn = 0 m_lTotalDataBytesOut = 0 Case CIFTP_DCCLOSED ' Data Channel Connection Closed DP "Data control connection closed" bDataControlChannelOpen = False Case CIFTP_DPORTSET ' Data Port Set DP "DataPortSet" ' Case CIFTP_LBPOP ' List Boxes Populated DP "List Boxes Populated" Case Else DP "Unknown event state (" & iState & ")" End Select dtLastServerResponse = Now ' record the time that info was recieved Exit Sub EventStateChanged_ErrHdlr: HandleInternalError End Sub ' EventStateChanged Public Sub AccessControlPacketReceived(ByRef Packet As String) ' Usage: This should be called from the AccessControlPacketReceived event code for the CIFTP control that is being wrapped if ' you wish to have the wrapper class track these packets. If bDumpAccessPackets Then DP "+++ Access Packet Start +++" DP Packet DP "+++ Access Packet End +++" & vbCrLf Else DP "AccessControlPacketReceived" End If dtLastServerResponse = Now ' record the time that the data was recieved End Sub ' AccessControlPacketReceived Public Sub DataControlPacketReceived(ByRef Packet As String, ByVal bytes_in As Integer) ' Usage: This should be called from the DataControlPacketReceived event code for the CIFTP control that is being wrapped if ' you wish to have the wrapper class track these packets. If you wish to use the timeout facilities provided by the wrapper ' you need to call this routine since it monitors the time at which packets are received. If bDumpDataPackets Then DP vbCrLf DP "--- Data Packet Start ---" DP Packet DP "--- Data Packet End [" & bytes_in & " bytes] ---" & vbCrLf Else DP "DataControlPacketReceived (" & bytes_in & ")" End If m_lTotalDataBytesIn = m_lTotalDataBytesIn + bytes_in dtLastServerResponse = Now ' record the time that data was last recieved End Sub ' DataControlPacketReceived Public Sub DataControlPacketSent(ByVal bytes_out As Integer) ' Usage: This should be called from the DataControlPacketSent event code for the CIFTP control that is being wrapped if ' you wish to have the wrapper class track these packets. If you wish to use the timeout facilities provided by the wrapper ' you need to call this routine since it monitors the time at which packets are received. DP "DataControlPacketSent (" & bytes_out & ")" m_lTotalDataBytesOut = m_lTotalDataBytesOut + bytes_out ' update byte count dtLastServerResponse = Now ' record the time that data was last sent End Sub ' DataControlPacketSent Public Sub InternetError(ByVal lErrorNumber As Long, ByRef sErrorMsg As String) ' Usage: This MUST be called from the InternetError event code for the CIFTP control that is being wrapped ' NOTE: The high level methods are not currently wrapped by this class, so you can safely ommit this call. DP "InternextError (" & lErrorNumber & ") - " & InternetErrDescription(lErrorNumber) SetError lErrorNumber, ERROR_TYPE_INTERNET End Sub ' InternetError Public Sub WSAError(ByVal iErrorNumber As Integer) ' Usage: This MUST be called from the WSAError event code for the CIFTP control that is being wrapped ' There appears to be a bug in the CIFTP control which causes an error of -10000 to be incorrectly raised. ' Since this does not represent a real error, we'll ignore this special case. If iErrorNumber = -10000 Then ' ignore this isn't a real error Else DP "WSAError (" & iErrorNumber & ") - " & WSAErrDescription(iErrorNumber) SetError CLng(iErrorNumber), ERROR_TYPE_WSA End If End Sub 'WSAError Public Function bLoggedIn() As Boolean 'Usage: determine if the user is logged in. Imperfect since we just check if the access control channel is open bLoggedIn = (bAccessControlChannelOpen = True) End Function ' bLoggedIn Public Property Get lTotalDataBytesIn() As Long ' Usage: provides read-only access to the # of bytes RECEIVED on the data control channel ' This is usefull for tracking the status of RETR operations lTotalDataBytesIn = m_lTotalDataBytesIn End Property Public Property Get lTotalDataBytesOut() As Long ' Usage: provides read-only access to the # of bytes SENT on the data control channel ' This is usefull for tracking the status of STOR/APPE operations lTotalDataBytesOut = m_lTotalDataBytesOut End Property '==================================================== ' +++ Private Routine Implementation Starts Here +++ '==================================================== Private Sub InitFTPStateMachine() ' Load the state array with the possible server response codes for the supported commands... DP "Initializing state machine..." ' USER iFTPStateMachine(CMD_USER, SUCCESS, 1) = 230 ' logged in iFTPStateMachine(CMD_USER, SUCCESS, 2) = 331 ' user ok, need pass iFTPStateMachine(CMD_USER, FAILURE, 1) = 332 ' need account to login iFTPStateMachine(CMD_USER, FAILURE, 2) = 530 ' not logged in iFTPStateMachine(CMD_USER, FAILURE, 3) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_USER, FAILURE, 4) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_USER, FAILURE, 5) = 421 ' service not avail, closing control connection! ' PASS iFTPStateMachine(CMD_PASS, SUCCESS, 1) = 230 ' logged in iFTPStateMachine(CMD_PASS, SUCCESS, 2) = 202 ' command not implemented superfulous at this site iFTPStateMachine(CMD_PASS, FAILURE, 1) = 332 ' need account to login iFTPStateMachine(CMD_PASS, FAILURE, 2) = 530 ' not logged in iFTPStateMachine(CMD_PASS, FAILURE, 3) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_PASS, FAILURE, 4) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_PASS, FAILURE, 5) = 503 ' bad sequence of commands iFTPStateMachine(CMD_PASS, FAILURE, 6) = 421 ' service not avail, closing control connection! ' CWD iFTPStateMachine(CMD_CWD, SUCCESS, 1) = 250 ' requested file action ok, completed iFTPStateMachine(CMD_CWD, FAILURE, 1) = 530 ' not logged in iFTPStateMachine(CMD_CWD, FAILURE, 2) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_CWD, FAILURE, 3) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_CWD, FAILURE, 4) = 502 ' cmd not implemented iFTPStateMachine(CMD_CWD, FAILURE, 5) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_CWD, FAILURE, 6) = 550 ' action not taken (file unavail., not found, etc.) ' CDUP iFTPStateMachine(CMD_CDUP, SUCCESS, 1) = 200 ' command ok iFTPStateMachine(CMD_CDUP, FAILURE, 1) = 530 ' not logged in iFTPStateMachine(CMD_CDUP, FAILURE, 2) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_CDUP, FAILURE, 3) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_CDUP, FAILURE, 4) = 502 ' cmd not implemented iFTPStateMachine(CMD_CDUP, FAILURE, 5) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_CDUP, FAILURE, 6) = 550 ' action not taken (file unavail., not found, etc.) ' TYPE iFTPStateMachine(CMD_TYPE, SUCCESS, 1) = 200 ' command ok iFTPStateMachine(CMD_TYPE, FAILURE, 1) = 530 ' not logged in iFTPStateMachine(CMD_TYPE, FAILURE, 2) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_TYPE, FAILURE, 3) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_TYPE, FAILURE, 4) = 504 ' command not implemented for specified parameter iFTPStateMachine(CMD_TYPE, FAILURE, 5) = 421 ' service not avail, closing control connection! ' PWD iFTPStateMachine(CMD_PWD, SUCCESS, 1) = 257 ' "pathname" created (ok) iFTPStateMachine(CMD_PWD, FAILURE, 1) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_PWD, FAILURE, 2) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_PWD, FAILURE, 3) = 502 ' cmd not implemented iFTPStateMachine(CMD_PWD, FAILURE, 4) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_PWD, FAILURE, 5) = 550 ' action not taken (file unavail., not found, etc.) ' SYST iFTPStateMachine(CMD_SYST, SUCCESS, 1) = 215 ' NAME system type iFTPStateMachine(CMD_SYST, FAILURE, 1) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_SYST, FAILURE, 2) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_SYST, FAILURE, 3) = 502 ' cmd not implemented iFTPStateMachine(CMD_SYST, FAILURE, 4) = 421 ' service not avail, closing control connection! ' QUIT iFTPStateMachine(CMD_QUIT, SUCCESS, 1) = 221 ' service closing control connection iFTPStateMachine(CMD_QUIT, FAILURE, 1) = 500 ' syntax err, cmd not recognized ' PASV iFTPStateMachine(CMD_PASV, SUCCESS, 1) = 227 ' entering passive mode iFTPStateMachine(CMD_PASV, FAILURE, 1) = 530 ' not logged in iFTPStateMachine(CMD_PASV, FAILURE, 2) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_PASV, FAILURE, 3) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_PASV, FAILURE, 4) = 502 ' cmd not implemented iFTPStateMachine(CMD_PASV, FAILURE, 5) = 421 ' service not avail, closing control connection! ' LIST iFTPStateMachine(CMD_LIST, SUCCESS, 1) = 226 ' closing data connection - requested file action ok iFTPStateMachine(CMD_LIST, SUCCESS, 2) = 250 ' requested file action ok, completed iFTPStateMachine(CMD_LIST, FAILURE, 1) = 425 ' can't open data connection iFTPStateMachine(CMD_LIST, FAILURE, 2) = 426 ' connection closed, transfer aborted iFTPStateMachine(CMD_LIST, FAILURE, 3) = 450 ' requested file action not taken, file unavailable (.e.g. file busy) iFTPStateMachine(CMD_LIST, FAILURE, 4) = 451 ' requested file action aborted: local error processing iFTPStateMachine(CMD_LIST, FAILURE, 5) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_LIST, FAILURE, 6) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_LIST, FAILURE, 7) = 502 ' cmd not implemented iFTPStateMachine(CMD_LIST, FAILURE, 8) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_LIST, FAILURE, 9) = 530 ' not logged in ' RETR iFTPStateMachine(CMD_RETR, SUCCESS, 1) = 226 ' closing data connection - requested file action ok iFTPStateMachine(CMD_RETR, SUCCESS, 2) = 250 ' requested file action ok, completed iFTPStateMachine(CMD_RETR, FAILURE, 1) = 425 ' can't open data connection iFTPStateMachine(CMD_RETR, FAILURE, 2) = 426 ' connection closed, transfer aborted iFTPStateMachine(CMD_RETR, FAILURE, 3) = 450 ' requested file action not taken, file unavailable (.e.g. file busy) iFTPStateMachine(CMD_RETR, FAILURE, 4) = 451 ' requested file action aborted: local error processing iFTPStateMachine(CMD_RETR, FAILURE, 5) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_RETR, FAILURE, 6) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_RETR, FAILURE, 7) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_RETR, FAILURE, 8) = 530 ' not logged in ' STOR iFTPStateMachine(CMD_STOR, SUCCESS, 1) = 226 ' closing data connection - requested file action ok iFTPStateMachine(CMD_STOR, SUCCESS, 2) = 250 ' requested file action ok, completed iFTPStateMachine(CMD_STOR, FAILURE, 1) = 425 ' can't open data connection iFTPStateMachine(CMD_STOR, FAILURE, 2) = 426 ' connection closed, transfer aborted iFTPStateMachine(CMD_STOR, FAILURE, 3) = 450 ' requested file action not taken, file unavailable (.e.g. file busy) iFTPStateMachine(CMD_STOR, FAILURE, 4) = 451 ' requested file action aborted: local error processing iFTPStateMachine(CMD_STOR, FAILURE, 5) = 551 ' requested action aborted, page type unknown iFTPStateMachine(CMD_STOR, FAILURE, 6) = 552 ' requested file action aborted -- exceeded storage allocation iFTPStateMachine(CMD_STOR, FAILURE, 7) = 532 ' need an account to stor files iFTPStateMachine(CMD_STOR, FAILURE, 8) = 553 ' requested action not taken -- filename not allowed iFTPStateMachine(CMD_STOR, FAILURE, 9) = 452 ' requested action not taken -- insufficient storage space in system iFTPStateMachine(CMD_STOR, FAILURE, 10) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_STOR, FAILURE, 11) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_STOR, FAILURE, 12) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_STOR, FAILURE, 13) = 530 ' not logged in ' APPE iFTPStateMachine(CMD_APPE, SUCCESS, 1) = 226 ' closing data connection - requested file action ok iFTPStateMachine(CMD_APPE, SUCCESS, 2) = 250 ' requested file action ok, completed iFTPStateMachine(CMD_APPE, FAILURE, 1) = 425 ' can't open data connection iFTPStateMachine(CMD_APPE, FAILURE, 2) = 426 ' connection closed, transfer aborted iFTPStateMachine(CMD_APPE, FAILURE, 3) = 450 ' requested file action not taken, file unavailable (.e.g. file busy) iFTPStateMachine(CMD_APPE, FAILURE, 4) = 451 ' requested file action aborted: local error processing iFTPStateMachine(CMD_APPE, FAILURE, 5) = 551 ' requested action aborted, page type unknown iFTPStateMachine(CMD_APPE, FAILURE, 6) = 552 ' requested file action aborted -- exceeded storage allocation iFTPStateMachine(CMD_APPE, FAILURE, 7) = 532 ' need an account to stor files iFTPStateMachine(CMD_APPE, FAILURE, 8) = 553 ' requested action not taken -- filename not allowed iFTPStateMachine(CMD_APPE, FAILURE, 9) = 452 ' requested action not taken -- insufficient storage space in system iFTPStateMachine(CMD_APPE, FAILURE, 10) = 500 ' syntax err, cmd not recognized iFTPStateMachine(CMD_APPE, FAILURE, 11) = 501 ' syntax err in param or arg iFTPStateMachine(CMD_APPE, FAILURE, 12) = 421 ' service not avail, closing control connection! iFTPStateMachine(CMD_APPE, FAILURE, 13) = 530 ' not logged in iFTPStateMachine(CMD_APPE, FAILURE, 14) = 550 ' action not taken (file unavail., not found, etc.) iFTPStateMachine(CMD_APPE, FAILURE, 15) = 502 ' cmd not implemented End Sub ' InitFTPStateMachine Private Function bExecCmd(iCmd As Byte) As Boolean ' This is the work-horse function for this class module ' It is called internally to make the actual calls to the ' ftp commands that are supported by the CIFTP control ' NOTE: This function is a candidate to become public. There are times when ' it would be convenient for users to simply invoke one of the supported commands ' directly (e.g. TYPE). However, this would require additional logic to be added ' since the routine, in its current form, assumes that a data channel has been ' established where necessary, prior to being called. A better strategy might ' be to write additional public routines that perform the needed functions or ' to write a general purpose "ProcessFTPCommand" routine that would invoke the ' CIFTP.SendFTPCommand. Dim dtStart As Date, iTimeout As Integer, iSecs As Integer, bTimedOut As Boolean On Error GoTo bExecCmd_ErrHdlr bExecCmd = False ' Assume worst case bFileClosed = False ' Reset flag that indicates that the FileClosed event has fired ClearSRQueue ' Clear the server response queue Select Case iCmd ' Case CMD_CONNECT ' connect to access control channel Case CMD_USER DP "Calling USER..." objFTP.USER Case CMD_PASS DP "Calling PASS..." objFTP.PASS Case CMD_CWD DP "Calling CWD..." objFTP.CWD Case CMD_CDUP DP "Calling CDUP..." objFTP.CDUP Case CMD_QUIT DP "Calling QUIT..." objFTP.QUIT Case CMD_PASV DP "Calling PASV..." objFTP.PASV Case CMD_TYPE DP "Calling TYPE..." objFTP.TYPE Case CMD_STOR DP "Calling STOR..." objFTP.STOR Case CMD_RETR DP "Calling RETR..." objFTP.RETR Case CMD_LIST DP "Calling LIST..." objFTP.List Case CMD_APPE DP "Calling APPE..." objFTP.APPE Case CMD_PWD DP "Calling PWD..." objFTP.PWD Case CMD_SYST DP "Calling SYST..." objFTP.SYST 'TO DO: add SendFTPCommand support here Case Else DP "bExecCmd: ERROR - Unknown Command (" & iCmd & ")" HandleInternalError Exit Function End Select ' Now that we've issued the command, wait for the server's response... bExecCmd = bWaitOnServerResponse(iCmd) Exit Function bExecCmd_ErrHdlr: HandleInternalError ' no corrective action implemented, just fail End Function ' bExecCmd Private Function bWaitOnServerResponse(iCmd As Byte) As Boolean Dim dtStart As Date, iSecs As Integer, bTimedOut As Boolean Dim i As Integer, j As Integer, iInitQPos As Integer On Error GoTo bWaitOnServerResponse_ErrHdlr bWaitOnServerResponse = False ' Check the Server Response Queue for input. If no conclusive response is found try again until ' either a definitive response is received OR an error is raised OR the timeout period expires... CheckItOut: iInitQPos = iQPos For i = 1 To iInitQPos For j = 1 To MAX_CODES If SRQueue(i).iCode = iFTPStateMachine(iCmd, SUCCESS, j) Then DP "Server responded Affirmatively - " & SRQueue(i).iCode ' We need to do some special case processing for the RETR and LIST commands ' Both of these cause the FileClosed event to fire AFTER the server responds affirmatively, ' so we need to wait on these events before considering the command to be completed If iCmd = CMD_RETR Or iCmd = CMD_LIST Then DP "Waiting on FileClosed event to complete the command..." bWaitOnServerResponse = bWaitOnFileClosed() Else ' otherwise, we're done bWaitOnServerResponse = True End If Exit Function ElseIf SRQueue(i).iCode = iFTPStateMachine(iCmd, FAILURE, j) Then DP "Server Responded Negatively! - " & SRQueue(i).iCode SetError (ERR_SERVER_REQUEST_FAILED) CloseDataControlChannel ' make sure the data channel gets closed Exit Function Else ' The server responded with a code that is not in the state table ' Some servers do not strictly follow the RFC, so they may return ' a failure code that is not in our state table. if the code is >= 400, ' then the command has failed. Handle such cases by treating it as ' a failed request... If SRQueue(i).iCode >= 400 Then DP "Server responded with non-standard negative response code - " & SRQueue(i).iCode DP "Requested command did not succeed." SetError (ERR_SERVER_REQUEST_FAILED) CloseDataControlChannel ' make sure the data channel gets closed Exit Function End If End If Next j Next i ' Inconclusive response so pound sand and check again... If iQPos <> 0 Then DP "Server did not respond conclusively, waiting for more server responses..." bTimedOut = False dtLastServerResponse = Now While iQPos = iInitQPos And Not bTimedOut And Not bFTPError() DoEvents If iTimeoutValue > 0 Then ' if a timeout value exists, then check to see if the specified threshold has been reached iSecs = DateDiff("s", Now, dtLastServerResponse) If Abs(iSecs) > iTimeoutValue Then bTimedOut = True End If Wend If iQPos <> iInitQPos Then DP "Checking Response queue for new input..." GoTo CheckItOut ' Try again ElseIf bTimedOut = True Then DP "Timed out waiting for server response!" SetError (ERR_TIMED_OUT) Else ' bFTPError is True End If Exit Function bWaitOnServerResponse_ErrHdlr: HandleInternalError End Function ' WaitOnServerResponse Private Sub CloseDataControlChannel() ' Utility routine that closes the data control channel by calling CleanupDataConnection On Error GoTo bCloseControlChannel_ErrHdlr If bDataControlChannelOpen Then DP "Closing data channel via CleanupDataConnection..." objFTP.CleanupDataConnection bDataControlChannelOpen = False ' this should be set in EventStateChanged, but let's make sure End If Exit Sub bCloseControlChannel_ErrHdlr: HandleInternalError End Sub ' CloseDataControlChannel Private Function bWaitOnFileClosed() As Boolean ' Wait for the file closed event to fire or for the timeout period to expire. ' Returns True if FileClosed fires, False if timeout expires or an error occurs Dim dtStart As Date, bTimedOut As Boolean, iSecs As Integer dtStart = Now While Not bFileClosed And Not bTimedOut And Not bFTPError() DoEvents If iTimeoutValue > 0 Then ' if a timeout value exists, then check to see if the specified threshold has been reached iSecs = DateDiff("s", Now, dtStart) If Abs(iSecs) > iTimeoutValue Then bTimedOut = True End If Wend bWaitOnFileClosed = bFileClosed If bTimedOut Then ' sometimes the FileClosed event will not fire even though the requested action has completed. ' This is an anomaly in the CIFTP control DP "Timed out waiting for FileClosed event. Request MAY NOT have completed" SetError (ERR_TIMED_OUT) End If End Function ' bWaitOnFileClosed Private Sub SetError(lCode As Long, Optional vntErrorType) ' By default errors are assumed to be type "OTHER" (non WSA/Internet) If IsMissing(vntErrorType) Then LastError.iType = ERROR_TYPE_OTHER Else LastError.iType = CInt(vntErrorType) End If LastError.lCode = lCode End Sub ' SetError Private Function sGetOtherError() As String Dim sErr As String On Error Resume Next Select Case LastError.lCode Case ERR_ROUTINE_ERROR sErr = Error(iInternaleError) Case ERR_BAD_OR_MISSING_PARAM sErr = "Bad or Missing Parameter" Case ERR_USER_ERROR sErr = "User Error" Case ERR_CLASS_NOT_INITIALIZED ' user is calling a function w/o first initializing the class sErr = "Class not initialized. bInit must be called before using any class module functions." Case ERR_UNEXPECTED_STATE ' e.g. user calls bLogout, but there access channel is closed sErr = "Unexpected FTP state encountered" Case ERR_SERVER_REQUEST_FAILED sErr = sGetContentOfSRQueue Case ERR_ACCESS_CONN_LOST sErr = "Access control channel dropped unexpectedly" & vbCrLf & "You may have issued a command without successfully logging in" Case ERR_TIMED_OUT sErr = "Timeout expired waiting for operation to complete" Case ERR_INVALID_FUNC_CALL sErr = "Attempted to invoke a function while another function was still executing" Case ERR_CMD_ABORTED sErr = "Function was aborted (via bAbort) before completing" Case ERR_INVALID_ABORT sErr = "User called bAbort, but no function was executing" Case ERR_NOT_CONNECTED sErr = "Not connected to ftp server" Case Else sErr = "Unknown error (" & LastError.lCode & ")" End Select sGetOtherError = sErr End Function ' sGetInternalError Private Sub AddToSRQueue(ByVal iCode As Integer, sMsg As String) On Error GoTo AddToSRQueue_ErrHdlr iQPos = iQPos + 1 If iQPos > QUEUE_SIZE Then iQPos = 1 SRQueue(iQPos).iCode = iCode SRQueue(iQPos).sMsg = sMsg ' DP "SRQueue(" & iQPos & ") = " & iCode Exit Sub AddToSRQueue_ErrHdlr: HandleInternalError End Sub ' AddToSRQueue Private Function bCheckSRQueue(ByVal iCode As Integer) As Boolean On Error GoTo bCheckSRQueue_ErrHdlr Dim i As Integer bCheckSRQueue = False For i = 1 To iQPos If SRQueue(i).iCode = iCode Then bCheckSRQueue = True Exit Function End If Next Exit Function bCheckSRQueue_ErrHdlr: HandleInternalError End Function ' bCheckSRQueue Private Function sGetContentOfSRQueue() As String Dim i As Integer On Error Resume Next For i = 1 To iQPos ' sGetContentOfSRQueue = sGetContentOfSRQueue & SRQueue(i).iCode & " - " & SRQueue(i).sMsg & vbCrLf sGetContentOfSRQueue = sGetContentOfSRQueue & SRQueue(i).sMsg & vbCrLf Next End Function ' sGetContentOfSRQueue Private Sub ClearSRQueue() On Error Resume Next Dim i As Integer For i = 1 To iQPos SRQueue(i).iCode = 0 SRQueue(i).sMsg = "" Next iQPos = 0 End Sub ' ClearSRQueue Private Sub HandleNotLoggedIn() ' This should be called if the user attempts to make a function call without first logging in to the server ' Call bLoggedIn to determine if a server connection is active. DP "ERROR: Not connected to ftp server" SetError (ERR_NOT_CONNECTED) End Sub ' HandleNotLoggedIn Private Sub DP(sMsg As String) Debug.Print sMsg ' Could add code here to dump output to a form, listbox, file, etc. ' This would be usefull for run time debugging/auditing End Sub ' DP Private Sub Class_Initialize() ' Set the initial values of class members... Set objFTP = Nothing iTimeoutValue = DEFAULT_TIMEOUT ' You may want to turn these on for debugging purposes. ' This can be done here or dynamically from client side code ' bDumpAccessPackets = True ' bDumpDataPackets = True End Sub Private Function bIsIPAddress(sHostName As String) As Boolean ' Determine if the string passed in represents a valid IP address ' While crude and hardly bullet proof, this will work with valid IPs Dim ip(4) As String, s As String, iLen As Integer, i As Integer On Error GoTo bIPAddress_ErrHdlr bIsIPAddress = False ' Assume it's not an IP address s = sHostName i = InStr(1, s, ".") If i <> 0 Then iLen = Len(s) ip(1) = Left(s, i - 1) s = Right(s, iLen - i) i = InStr(1, s, ".") If i <> 0 Then iLen = Len(s) ip(2) = Left(s, i - 1) s = Right(s, iLen - i) i = InStr(1, s, ".") If i <> 0 Then iLen = Len(s) ip(3) = Left(s, i - 1) s = Right(s, iLen - i) i = InStr(1, s, ".") If i = 0 Then ip(4) = s ' if we've gotten this far and all tokens are numeric and less than 3 digits, then we can treat it as an IP address For i = 1 To 4 If Not IsNumeric(ip(i)) Or Len(ip(i)) > 3 Then Exit Function Else ' also make sure the numbers are within the valid IP limits If CInt(ip(i)) < 0 Or CInt(ip(i)) > 255 Then Exit Function End If End If Next i bIsIPAddress = True ' passed all criteria, so we'll treat it as an IP address End If End If End If End If Exit Function bIPAddress_ErrHdlr: HandleInternalError ' if any errors occur processing the name, we don't treat it as an IP address End Function ' bNameIsIPAddress Private Sub HandleInternalError() DP "ERROR (" & Err.Number & ") - " & Err.Description iInternaleError = Err.Number ' save error number for sGetLastError routine SetError ERR_ROUTINE_ERROR End Sub ' HandleInternalError Private Function bConnectToAccessControlChannel() As Boolean Dim dtStart As Date, iSecs As Integer, bTimedOut As Boolean On Error GoTo bConnectToAccessControlChannel_ErrHdlr bConnectToAccessControlChannel = False ' Assume worst case If bAccessControlChannelOpen = True Then bConnectToAccessControlChannel = True ' we're already connected, so we're done Exit Function End If ' We don't have an active access control channel, so request one... ' Wait until the AccessControlChannelConnection event fires (it sets bAccessControlChannelOpen)... bTimedOut = False dtStart = Now DP "Calling ConnectToAccessControlChannel..." objFTP.ConnectToAccessControlChannel While bAccessControlChannelOpen = False And Not bTimedOut And Not bFTPError() DoEvents If iTimeoutValue > 0 Then ' if a timeout value exists, then check to see if the specified threshold has been reached iSecs = DateDiff("s", Now, dtStart) If Abs(iSecs) > iTimeoutValue Then bTimedOut = True End If Wend ' Set the result value -- if we didn't time out then we got the requested connection... bConnectToAccessControlChannel = (bTimedOut = False And Not bFTPError()) Exit Function bConnectToAccessControlChannel_ErrHdlr: HandleInternalError End Function ' bConnectToAccessControlChannel Private Function bConnectToDataChannel() As Boolean ' Has error handling which expects it to only be called from within a public user function (bGetFile, bPutFile, etc.) Dim dtStart As Date, iSecs As Integer, bTimedOut As Boolean, bSuccess As Boolean On Error GoTo bConnectToDataChannel_ErrHdlr bConnectToDataChannel = False ' Assume worst case ClearErrorFlags ' clear flags indicating that InternetError or WSAError fired bSuccess = bExecCmd(CMD_PASV) If Not bSuccess Then Exit Function ' <-- Early out! Debug.Print "Data Port Established (" & objFTP.DataPort & ")" ' Now request a Data Channel... bDataControlChannelOpen = False ' reset flag before requesting a channel ' We should probably check to see if a data channel is already active Debug.Print "Calling ConnectToDataChannel..." dtStart = Now objFTP.ConnectToDataChannel ' ===================================== NOTE ===================================== ' If we are performing an opperation that sends data to the server (APPE/STOR), ' then we cannot call DoEvents between the time we connect to the data channel and ' the time that we issue the APPE or STOR method. This is because the control ' uses the windows message queue and DoEvents causes potential synchronization ' problems. Therefore, we do an early exit in this case and allow bPutFile to ' immediately call STOR or APPE. ' ===================================== NOTE ===================================== If sCurrUserFuncName = "bPutFile" Then ' see above note bConnectToDataChannel = True Exit Function End If ' Wait until the DataChannelConnection event fires and sets our flag... While bDataControlChannelOpen = False And Not bTimedOut And Not bFTPError() DoEvents If iTimeoutValue > 0 Then ' if a timeout value exists, then check to see if the specified threshold has been reached iSecs = DateDiff("s", Now, dtStart) If Abs(iSecs) > iTimeoutValue Then bTimedOut = True End If Wend ' Set the result value -- if we didn't time out then we got the requested connection... bConnectToDataChannel = (bTimedOut = False And Not bFTPError()) Exit Function bConnectToDataChannel_ErrHdlr: HandleInternalError End Function ' bConnectToDataChannel Private Sub Class_Terminate() If bInitialized Then Set objFTP = Nothing End If End Sub Private Sub DumpFTPSettings(iFunction As Integer) On Error Resume Next ' Dumps the relevant FTP settings for the specified function With objFTP Select Case iFunction Case USER_FUNC_LOGIN DP "HostName = " & .HostName DP "HostAddress = " & .HostAddress DP "AccessPort = " & .AccessPort DP "LoginName = " & .LoginName DP "Password = " & .Password DP "WorkingDirectory = " & .WorkingDirectory Case USER_FUNC_LOGOUT DP "HostName = " & .HostName DP "HostAddress = " & .HostAddress Case USER_FUNC_GET_DIR DP "HostName = " & .HostName DP "HostAddress = " & .HostAddress DP "AccessPort = " & .AccessPort DP "WorkingDirectory = " & .WorkingDirectory Case USER_FUNC_GET_FILE, USER_FUNC_PUT_FILE DP "HostName = " & .HostName DP "HostAddress = " & .HostAddress DP "AccessPort = " & .AccessPort DP "WorkingDirectory = " & .WorkingDirectory DP "LocalFileName = " & .LocalFileName DP "RemoteFileName = " & .RemoteFileName Case Else DP "Unknown function value (" & iFunction & ")" End Select End With DP vbCrLf End Sub ' DumpFTPSettings Private Function bInitUserCall(sFuncName As String) As Boolean ' NOTE: This should be called at the beginning of each public functions! #If Win32 Then Const Pointer = 13 ' ccArrowHourglass #Else Const Pointer = 11 'ccArrow #End If On Error GoTo bInitUserCall_ErrHdlr ' Don't allow users to call a function if there is another function currently executing... If sCurrUserFuncName <> "" Then DP "Error user attempted to invoke '" & sFuncName & "' while another function ('" & sCurrUserFuncName & "') was in progress" ' SetError ERR_INVALID_FUNC_CALL ' We don't want to raise an error here because it will cause the currently executing function to potentially fail Exit Function Else sCurrUserFuncName = sFuncName End If bInitUserCall = False ' Assume worst case ' Dump header info... DP vbCrLf & "============ " & sFuncName & " Started at " & Now & " ============" & vbCrLf ' Reset error flags... ClearErrorFlags ' Set time at which last function was called by the user... dtLastUserRequest = Now ' Determine if the class module has been initialized... bInitUserCall = bClassInitialized() ' If we failed then clean up... If Not bInitUserCall Then ' failed... DP sGetLastError EndUserCall Else ' success... objFTP.Parent.MousePointer = Pointer ' change pointer to hourglass. EndUserCall resets it End If Exit Function bInitUserCall_ErrHdlr: HandleInternalError End Function ' bInitUserCall Private Sub EndUserCall() On Error Resume Next ' NOTE: This must be called at the end of ALL public functions! ' Dump foter info... DP vbCrLf & "=========== " & sCurrUserFuncName & " Completed at " & Now & " ===========" & vbCrLf sCurrUserFuncName = "" ' clear function name variable (this will allow users to call another function) If bInitialized Then objFTP.Parent.MousePointer = 0 ' ccDefault ' change pointer to default ' [should probably save the original shape and restore that,since it may not be the default] End If End Sub ' EndUserCall Private Function bClassInitialized() As Boolean ' Tests to see if the class has been initialized (via bInit function) If Not bInitialized Then SetError ERR_CLASS_NOT_INITIALIZED bClassInitialized = bInitialized End Function ' bClassInitialized 'Property Let WorkingDirectory(s As String) ' objFTP.WorkingDirectory = s 'End Property 'Property Get WorkingDirectory() As String ' WorkingDirectory = objFTP.WorkingDirectory 'End Property Private Sub ClearErrorFlags() ' Internal routine that resets the error flags. This is called in each of the supporting ' functions before initiating FTP requests. LastError.iType = ERROR_TYPE_NONE LastError.lCode = 0 End Sub ' ClearErrorFlags Private Function bFTPError() As Boolean ' Internal support function to determine if the control fired an error event. ' Note that this function relies on the flags being set in the WSAError ' and InternetError events...Or by an On Error Handler bFTPError = (ERROR_TYPE_NONE <> LastError.iType) End Function ' bFTPError